home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _1fce6dce9593ea0bb42d6b98c7de73d3 < prev    next >
Encoding:
Text File  |  2002-05-30  |  10.5 KB  |  444 lines
  1. package Tk::NoteBook;
  2. #
  3. # Implementation of NoteBook widget.
  4. # Derived from NoteBook.tcl in Tix 4.0
  5.  
  6. # Contributed by Rajappa Iyer <rsi@earthling.net>
  7. # Hacked by Nick for 'menu' traversal.
  8. # Restructured by Nick
  9.  
  10. use vars qw($VERSION);
  11.  
  12. $VERSION = '3.024'; # $Id: //depot/Tk8/Tixish/NoteBook.pm#24 $
  13. require Tk::NBFrame;
  14.  
  15. use base  qw(Tk::Derived Tk::NBFrame);
  16. Tk::Widget->Construct('NoteBook');
  17. use strict;
  18.  
  19. use Tk qw(Ev);
  20.  
  21. use Carp;
  22. require Tk::Frame;
  23.  
  24. sub TraverseToNoteBook;
  25.  
  26. sub ClassInit
  27. {
  28.  my ($class,$mw) = @_;
  29.  # class binding does not work right due to extra level of
  30.  # widget hierachy
  31.  $mw->bind($class,'<ButtonPress-1>', ['MouseDown',Ev('x'),Ev('y')]);
  32.  $mw->bind($class,'<ButtonRelease-1>', ['MouseUp',Ev('x'),Ev('y')]);
  33.  
  34.  $mw->bind($class,'<B1-Motion>', ['MouseDown',Ev('x'),Ev('y')]);
  35.  $mw->bind($class,'<Left>', ['FocusNext','prev']);
  36.  $mw->bind($class,'<Right>', ['FocusNext','next']);
  37.  
  38.  $mw->bind($class,'<Return>', 'SetFocusByKey');
  39.  $mw->bind($class,'<space>', 'SetFocusByKey');
  40.  return $class;
  41. }
  42.  
  43. sub raised
  44. {
  45.  return shift->{'topchild'};
  46. }
  47.  
  48. sub Populate
  49. {
  50.  my ($w, $args) = @_;
  51.  
  52.  $w->SUPER::Populate($args);
  53.  $w->{'pad-x1'} = 0;
  54.  $w->{'pad-x2'} = 0;
  55.  $w->{'pad-y1'} = 0;
  56.  $w->{'pad-y2'} = 0;
  57.  
  58.  $w->{'nWindows'} = 0;
  59.  $w->{'minH'} = 1;
  60.  $w->{'minW'} = 1;
  61.  
  62.  $w->{'counter'} = 0;
  63.  $w->{'resize'} = 0;
  64.  
  65.  $w->ConfigSpecs(-ipadx => ['PASSIVE', 'ipadX', 'Pad', 0],
  66.                  -ipady => ['PASSIVE', 'ipadY', 'Pad', 0],
  67.                  -takefocus => ['SELF', 'takeFocus', 'TakeFocus', 0],
  68.                  -dynamicgeometry => ['PASSIVE', 'dynamicGeometry', 'DynamicGeometry', 0]);
  69.  
  70.  # SetBindings
  71.  $w->bind('<Configure>','MasterGeomProc');
  72.  
  73.  $args->{-slave} = 1;
  74.  $args->{-takefocus} = 1;
  75.  $args->{-relief} = 'raised';
  76.  
  77.  $w->QueueResize;
  78. }
  79.  
  80.  
  81. #---------------------------
  82. # Public methods
  83. #---------------------------
  84.  
  85. sub page_widget
  86. {
  87.  my $w = shift;
  88.  $w->{'_pages_'} = {} unless exists $w->{'_pages_'};
  89.  my $h = $w->{'_pages_'};
  90.  if (@_)
  91.   {
  92.    my $name = shift;
  93.    if (@_)
  94.     {
  95.      my $cw = shift;
  96.      if (defined $cw)
  97.       {
  98.        $h->{$name} = $cw;
  99.       }
  100.      else
  101.       {
  102.        return delete $h->{$name};
  103.       }
  104.     }
  105.    return $h->{$name};
  106.   }
  107.  else
  108.   {
  109.    return (values %$h);
  110.   }
  111. }
  112.  
  113. sub add
  114. {
  115.  my ($w, $child, %args) = @_;
  116.  
  117.  croak("$child already exists") if defined $w->page_widget($child);
  118.  
  119.  my $f = Tk::Frame->new($w,Name => $child,-relief => 'raised');
  120.  
  121.  my $ccmd = delete $args{-createcmd};
  122.  my $rcmd = delete $args{-raisecmd};
  123.  $f->{-createcmd} = Tk::Callback->new($ccmd) if (defined $ccmd);
  124.  $f->{-raisecmd} = Tk::Callback->new($rcmd) if (defined $rcmd);
  125.  
  126.  # manage our geometry
  127.  $w->ManageGeometry($f);
  128.  # create default bindings
  129.  $f->bind('<Configure>',[$w,'ClientGeomProc','-configure', $f]);
  130.  $f->bind('<Destroy>',  [$w,'delete',$child,1]);
  131.  $w->page_widget($child,$f);
  132.  $w->{'nWindows'}++;
  133.  push(@{$w->{'windows'}}, $child);
  134.  $w->SUPER::add($child,%args);
  135.  return $f;
  136. }
  137.  
  138. sub raise
  139. {
  140.  my ($w, $child) = @_;
  141.  return unless defined $child;
  142.  if ($w->pagecget($child, -state) eq 'normal')
  143.   {
  144.    $w->activate($child);
  145.    $w->focus($child);
  146.    my $childw = $w->page_widget($child);
  147.    if ($childw)
  148.     {
  149.      if (defined $childw->{-createcmd})
  150.       {
  151.        $childw->{-createcmd}->Call($childw);
  152.        delete $childw->{-createcmd};
  153.       }
  154.      # hide the original visible window
  155.      my $oldtop = $w->{'topchild'};
  156.      if (defined($oldtop) && ($oldtop ne $child))
  157.       {
  158.        $w->page_widget($oldtop)->UnmapWindow;
  159.       }
  160.      $w->{'topchild'} = $child;
  161.      my $myW = $w->Width;
  162.      my $myH = $w->Height;
  163.  
  164.      my $cW = $myW - $w->{'pad-x1'} - $w->{'pad-x2'} - 2 * (defined $w->{-ipadx} ? $w->{-ipadx} : 0);
  165.      my $cH = $myH - $w->{'pad-y1'} - $w->{'pad-y2'} - 2 * (defined $w->{-ipady} ? $w->{-ipady} : 0);
  166.      my $cX = $w->{'pad-x1'} + (defined $w->{-ipadx} ? $w->{-ipadx} : 0);
  167.      my $cY = $w->{'pad-y1'} + (defined $w->{-ipady} ? $w->{-ipady} : 0);
  168.  
  169.      if ($cW > 0 && $cH > 0)
  170.       {
  171.        $childw->MoveResizeWindow($cX, $cY, $cW, $cH);
  172.        $childw->MapWindow;
  173.        $childw->raise;
  174.       }
  175.      if ((not defined $oldtop) || ($oldtop ne $child))
  176.       {
  177.        if (defined $childw->{-raisecmd})
  178.         {
  179.          $childw->{-raisecmd}->Call($childw);
  180.         }
  181.       }
  182.     }
  183.   }
  184. }
  185.  
  186. sub pageconfigure
  187. {
  188.  my ($w, $child, %args) = @_;
  189.  my $childw = $w->page_widget($child);
  190.  if (defined $childw)
  191.   {
  192.    my $ccmd = delete $args{-createcmd};
  193.    my $rcmd = delete $args{-raisecmd};
  194.    $childw->{-createcmd} = Tk::Callback->new($ccmd) if (defined $ccmd);
  195.    $childw->{-raisecmd} = Tk::Callback->new($rcmd) if (defined $rcmd);
  196.    $w->SUPER::pageconfigure($child, %args) if (keys %args);
  197.   }
  198. }
  199.  
  200. sub pages {
  201.     my ($w) = @_;
  202.     return @{$w->{'windows'}};
  203. }
  204.  
  205. sub pagecget
  206. {
  207.  my ($w, $child, $opt) = @_;
  208.  my $childw = $w->page_widget($child);
  209.  if (defined $childw)
  210.   {
  211.    return $childw->{-createcmd} if ($opt =~ /-createcmd/);
  212.    return $childw->{-raisecmd} if ($opt =~ /-raisecmd/);
  213.    return $w->SUPER::pagecget($child, $opt);
  214.   }
  215.  else
  216.   {
  217.    carp "page $child does not exist";
  218.   }
  219. }
  220.  
  221. sub delete
  222. {
  223.  my ($w, $child, $destroy) = @_;
  224.  my $childw = $w->page_widget($child,undef);
  225.  if (defined $childw)
  226.   {
  227.    $childw->bind('<Destroy>', undef);
  228.    $childw->destroy;
  229.    @{$w->{'windows'}} = grep($_ !~ /$child/, @{$w->{'windows'}});
  230.    $w->{'nWindows'}--;
  231.    $w->SUPER::delete($child);
  232.    # see if the child to be deleted was the top child
  233.    if ((defined $w->{'topchild'}) && ($w->{'topchild'} eq $child))
  234.     {
  235.      delete $w->{'topchild'};
  236.      if ( @{$w->{'windows'}})
  237.       {
  238.        $w->raise($w->{'windows'}[0]);
  239.       }
  240.     }
  241.   }
  242.  else
  243.   {
  244.    carp "page $child does not exist" unless $destroy;
  245.   }
  246. }
  247.  
  248. #---------------------------------------
  249. # Private methods
  250. #---------------------------------------
  251.  
  252. sub MouseDown {
  253.     my ($w, $x, $y) = @_;
  254.     my $name = $w->identify($x, $y);
  255.     $w->focus($name);
  256.     $w->{'down'} = $name;
  257. }
  258.  
  259. sub MouseUp {
  260.     my ($w, $x, $y) = @_;
  261.     my $name = $w->identify($x, $y);
  262.     if ((defined $name) &&
  263.         ($name eq $w->{'down'}) &&
  264.         ($w->pagecget($name, -state) eq 'normal')) {
  265.         $w->raise($name);
  266.     } else {
  267.         $w->focus($name);
  268.     }
  269. }
  270.  
  271. sub FocusNext {
  272.     my ($w, $dir) = @_;
  273.     my $name;
  274.  
  275.     if (not defined $w->info('focus')) {
  276.         $name = $w->info('active');
  277.         $w->focus($name);
  278.     } else {
  279.         $name = $w->info('focus' . $dir);
  280.         $w->focus($name);
  281.     }
  282. }
  283.  
  284. sub SetFocusByKey {
  285.     my ($w) = @_;
  286.  
  287.     my $name = $w->info('focus');
  288.     if (defined $name) {
  289.         if ($w->pagecget($name, -state) eq 'normal') {
  290.             $w->raise($name);
  291.             $w->activate($name);
  292.         }
  293.     }
  294. }
  295.  
  296. sub NoteBookFind {
  297.     my ($w, $char) = @_;
  298.  
  299.     my $page;
  300.     foreach $page (@{$w->{'windows'}}) {
  301.         my $i = $w->pagecget($page, -underline);
  302.         my $c = substr($page, $i, 1);
  303.         if ($char =~ /$c/) {
  304.             if ($w->pagecget($page, -state) ne 'disabled') {
  305.                 return $page;
  306.             }
  307.         }
  308.     }
  309.     return undef;
  310. }
  311.  
  312. # This is called by TraveseToMenu when an <Alt-Keypress> occurs
  313. # See the code in Tk.pm
  314. sub FindMenu {
  315.     my ($w, $char) = @_;
  316.  
  317.     my $page;
  318.     foreach $page (@{$w->{'windows'}}) {
  319.         my $i = $w->pagecget($page, -underline);
  320.         my $l = $w->pagecget($page, -label);
  321.         next if (not defined $l);
  322.         my $c = substr($l, $i, 1);
  323.         if ($char =~ /$c/i) {
  324.             if ($w->pagecget($page, -state) ne 'disabled') {
  325.                 $w->raise($page);
  326.                 return $w;
  327.             }
  328.         }
  329.     }
  330.     return undef;
  331. }
  332.  
  333.  
  334. sub MasterGeomProc
  335. {
  336.  my ($w) = @_;
  337.  if (Tk::Exists($w))
  338.   {
  339.    $w->{'resize'} = 0 unless (defined $w->{'resize'});
  340.    $w->QueueResize;
  341.   }
  342. }
  343.  
  344. sub SlaveGeometryRequest
  345. {
  346.  my $w = shift;
  347.  if (Tk::Exists($w))
  348.   {
  349.    $w->QueueResize;
  350.   }
  351. }
  352.  
  353. sub LostSlave {
  354.     my ($w, $s) = @_;
  355.     print "Loosing $s\n";
  356.     $s->UnmapWindow;
  357. }
  358.  
  359. sub ClientGeomProc
  360. {
  361.  my ($w, $flag, $client) = @_;
  362.  $w->QueueResize if (Tk::Exists($w));
  363.  if ($flag =~ /-lostslave/)
  364.   {
  365.    carp "Geometry Management Error: Another geometry manager has taken control of $client. This error is usually caused because a widget has been created in the wrong frame: it should have been created inside $client instead of $w";
  366.   }
  367. }
  368.  
  369. sub QueueResize
  370. {
  371.  my $w = shift;
  372.  $w->afterIdle(['Resize', $w]) unless ($w->{'resize'}++);
  373. }
  374.  
  375. sub Resize {
  376.  
  377.     my ($w) = @_;
  378.  
  379.     return unless Tk::Exists($w) && $w->{'nWindows'} && $w->{'resize'};
  380.  
  381.     my ($tW, $tH) = $w->geometryinfo;
  382.     $w->{'pad-x1'} = 2;
  383.     $w->{'pad-x2'} = 2;
  384.     $w->{'pad-y1'} = $tH + (defined $w->{'-ipadx'} ? $w->{'-ipadx'} : 0) + 1;
  385.     $w->{'pad-y2'} = 2;
  386.     $w->{'minW'} = $tW;
  387.     $w->{'minH'} = $tH;
  388.  
  389.     $w->{'resize'} = 0;
  390.     my $reqW = $w->{-width} || 0;
  391.     my $reqH = $w->{-height} || 0;
  392.  
  393.     if ($reqW * $reqH == 0)
  394.      {
  395.         if ((not defined $w->{-dynamicgeometry}) ||
  396.             ($w->{-dynamicgeometry} == 0)) {
  397.             $reqW = 1;
  398.             $reqH = 1;
  399.  
  400.             my $childw;
  401.             foreach $childw ($w->page_widget)
  402.              {
  403.                 my $cW = $childw->ReqWidth;
  404.                 my $cH = $childw->ReqHeight;
  405.                 $reqW = $cW if ($reqW < $cW);
  406.                 $reqH = $cH if ($reqH < $cH);
  407.             }
  408.         } else {
  409.             if (defined $w->{'topchild'}) {
  410.                 my $topw = $w->page_widget($w->{'topchild'});
  411.                 $reqW = $topw->ReqWidth;
  412.                 $reqH = $topw->ReqHeight;
  413.             } else {
  414.                 $reqW = 1;
  415.                 $reqH = 1;
  416.             }
  417.         }
  418.         $reqW += $w->{'pad-x1'} + $w->{'pad-x2'} + 2 * (defined $w->{-ipadx} ? $w->{-ipadx} : 0);
  419.         $reqH += $w->{'pad-y1'} + $w->{'pad-y2'} + 2 * (defined $w->{-ipady} ? $w->{-ipady} : 0);
  420.         $reqW = ($reqW > $w->{'minW'}) ? $reqW : $w->{'minW'};
  421.         $reqH = ($reqH > $w->{'minH'}) ? $reqH : $w->{'minH'};
  422.     }
  423.     if (($w->ReqWidth != $reqW) ||
  424.         ($w->ReqHeight != $reqH)) {
  425.         $w->{'counter'} = 0 if (not defined $w->{'counter'});
  426.         if ($w->{'counter'} < 50) {
  427.             $w->{'counter'}++;
  428.             $w->GeometryRequest($reqW, $reqH);
  429.             $w->afterIdle([$w,'Resize']);
  430.             $w->{'resize'} = 1;
  431.             return;
  432.         }
  433.     }
  434.     $w->{'counter'} = 0;
  435.     $w->raise($w->{'topchild'} || ${$w->{'windows'}}[0]);
  436.     $w->{'resize'} = 0;
  437. }
  438.  
  439. 1;
  440.  
  441. __END__
  442.  
  443. =cut
  444.